home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / dired / dired-nstd.el < prev    next >
Encoding:
Text File  |  1994-09-20  |  16.1 KB  |  439 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2. ;;; Jamie Zawinski <jwz@lucid.com> 7-may-91
  3. ;;;
  4. ;;; This makes dired buffers which display multiple directories display
  5. ;;; them in a tree rather than in an "ls -R"-like format.  Which, as every
  6. ;;; Lisp Machine hacker knows, is the Right Thing!
  7. ;;;
  8. ;;;   -rw-r--r--  1 jwz         31543 Mar 26 03:20 reportmail.el
  9. ;;;   -rw-r--r--  1 jwz         14919 Mar 26 03:20 reportmail.elc
  10. ;;;   drwxr-xr-x  2 jwz          1024 Apr  5 13:08 sk-dired/
  11. ;;;     -rw-r--r--  1 jwz          3258 Mar  6 06:33 ange-ftp-dired.el
  12. ;;;     -rw-r--r--  1 jwz          1750 Mar 12 15:04 ange-ftp-dired.elc
  13. ;;;   -rw-r--r--  1 jwz          3151 Mar 29 00:01 symbol-syntax.el
  14. ;;;   -rw-r--r--  1 jwz          1504 Mar 29 01:01 symbol-syntax.elc
  15.  
  16. ;;; This program is free software; you can redistribute it and/or modify
  17. ;;; it under the terms of the GNU General Public License as published by
  18. ;;; the Free Software Foundation; either version 2, or (at your option)
  19. ;;; any later version.
  20. ;;;
  21. ;;; This program is distributed in the hope that it will be useful,
  22. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24. ;;; GNU General Public License for more details.
  25. ;;;
  26. ;;; A copy of the GNU General Public License can be obtained from this
  27. ;;; program's author (send electronic mail to the above address) or from
  28. ;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  
  30. (defconst dired-subdir-alist nil
  31.   "Association list of subdirectories and their buffer positions:
  32.  
  33.   ((LASTDIR STARTMARKER ENDMARKER NESTING-DEPTH)
  34.    ...
  35.    (DEFAULT-DIRECTORY POINTMIN POINTMAX 0)).
  36. "
  37. ;;The markers point right at the end of the line, so that the cursor
  38. ;;looks at either \\n or \\r, the latter for a hidden subdir.
  39. ;; The directories must be file-name-as-directory, of course.
  40. )
  41.  
  42. (defun dired-simple-subdir-alist ()
  43.   ;; Build and return `dired-subdir-alist' assuming just the top level
  44.   ;; directory to be inserted.  Don't parse the buffer.
  45.   (set (make-local-variable 'dired-subdir-alist)
  46.        (list (list default-directory
  47.            (point-min-marker) (point-max-marker) 0))))
  48.  
  49. (define-key dired-mode-map "i" 'dired-insert-subdir-inline)
  50. (define-key dired-mode-map "j" 'dired-maybe-insert-subdir)
  51.  
  52. ;;; ## these should be macros when this is integrated with the distribution.
  53. (defun dired-get-subdir-min (elt) (nth 1 elt))
  54. (defun dired-get-subdir-max (elt) (nth 2 elt))
  55.  
  56. (defun dired-subdir-min ()
  57.   (let ((d (dired-current-directory))
  58.     c)
  59.     (if (setq c (assoc d dired-subdir-alist))
  60.     (marker-position (dired-get-subdir-min c))
  61.       (error "not in a subdir!"))))
  62.  
  63. (defun dired-subdir-max ()
  64.   (let ((d (dired-current-directory))
  65.     c)
  66.     (if (setq c (assoc d dired-subdir-alist))
  67.     (marker-position (dired-get-subdir-max c))
  68.     (point-max))))
  69.  
  70. (defun dired-clear-alist ()
  71.   (while dired-subdir-alist
  72.     (let ((elt (car dired-subdir-alist)))
  73.       (set-marker (nth 1 elt) nil)
  74.       (set-marker (nth 2 elt) nil))
  75.     (setq dired-subdir-alist (cdr dired-subdir-alist))))
  76.  
  77. (defun dired-unsubdir (dir)
  78.   ;; Remove DIR from the alist.
  79.   ;; also remove any directories which are inside of it.
  80.   (let* ((elt (assoc dir dired-subdir-alist))
  81.      (min (nth 1 elt))
  82.      (max (nth 2 elt))
  83.      other-elt
  84.      (rest dired-subdir-alist))
  85.     (while rest
  86.       (setq other-elt (car rest))
  87.       (if (and (<= min (nth 1 other-elt))
  88.            (>= max (nth 2 other-elt)))
  89.       (setq dired-subdir-alist (delq other-elt dired-subdir-alist)))
  90.       (setq rest (cdr rest)))))
  91.  
  92. ;;; this needs to be changed to grok indentation.  Or not. -jwz
  93. ;;; Probably not, as dired-revert either starts with one dir and inserting
  94. ;;; then enlarges the alist automatically, or it inserts all dirs with
  95. ;;; one "ls -lR". -sk
  96. (defun dired-build-subdir-alist ()
  97.   "Build dired-subdir-alist by parsing the buffer and return it's new value."
  98.   (interactive)
  99.   (dired-clear-alist)
  100.   (save-excursion
  101.     (let ((count 0))
  102.       (goto-char (point-min))
  103.       (setq dired-subdir-alist nil)
  104.       (while (re-search-forward dired-subdir-regexp nil t)
  105.     (setq count (1+ count))
  106.     (dired-alist-add (buffer-substring (match-beginning 1)
  107.                        (match-end 1))
  108.              ;; Put subdir boundary between lines:
  109.              (save-excursion
  110.                (goto-char (match-beginning 0))
  111.                (beginning-of-line)
  112.                (point-marker))
  113.              ;; isn't this wrong when already more than one
  114.              ;; subdir is present with -lR?
  115.              ;; maybe.  I don't know.   But we can't call
  116.              ;; dired-subdir-max here, it loops.  -jwz.
  117.              (point-max-marker)
  118.              0)
  119.     (message "%d" count))
  120.       (message "%d director%s." count (if (= 1 count) "y" "ies"))
  121.       ;; return new alist:
  122.       dired-subdir-alist)))
  123.  
  124. (defun dired-alist-add (dir start-marker end-marker indentation-depth)
  125.   ;; indentation-depth may be 0 for more than one directory -- this happens
  126.   ;; when "ls -R" format is used.
  127.   ;; ## debugging code
  128.   (or start-marker (error "start marker nil"))
  129.   (or end-marker (error "end marker nil"))
  130.   ;;(or (/= start-marker end-marker) (error "markers are the same"))
  131.   (let ((old (assoc dir dired-subdir-alist)))
  132.     (setq dired-subdir-alist
  133.       (cons (list (dired-normalize-subdir dir)
  134.               start-marker end-marker
  135.               (or indentation-depth 0))
  136.         (delq old dired-subdir-alist)))
  137.     (dired-alist-sort)))
  138.  
  139. ;; can't see at the moment how this could work with a mixed format
  140. ;; alist -sk
  141. (defun dired-current-directory (&optional relative)
  142.   "Get the subdirectory to which this line belongs.
  143. This returns a string with trailing slash, like default-directory.
  144. Optional argument means return a name relative to default-directory."
  145.   (let (elt
  146.     (here (point))
  147.     (alist (or dired-subdir-alist (dired-build-subdir-alist)))
  148.     best-so-far)
  149.     (while alist
  150.       (setq elt (car alist))
  151.       (if (or (< here (nth 1 elt))
  152.           (> here (nth 2 elt)))
  153.       nil ;; the subdir is disjoint
  154.     ;; otherwise it's on the path between the current file and the root.
  155.     ;; decide if it's deeper than what we've already got.
  156.     (if (or (null best-so-far)
  157.         (< (- (nth 2 elt) (nth 1 elt))
  158.            (- (nth 2 best-so-far) (nth 1 best-so-far))))
  159.         (setq best-so-far elt)))
  160.       (setq alist (cdr alist)))
  161.     (if best-so-far
  162.     (if relative
  163.         (dired-make-relative (car best-so-far) default-directory)
  164.       (car best-so-far))
  165.       (progn
  166.     (dired-build-subdir-alist)
  167.     (dired-current-directory relative)))))
  168.  
  169. (defun dired-insert-subdir-del (element)
  170.   ;; Erase an already present subdir (given by ELEMENT) from buffer.
  171.   ;; Move to that buffer position.  Return a mark-alist.
  172.   (let ((begin-marker (dired-get-subdir-min element))
  173.     (end-marker (dired-get-subdir-max element)))
  174.     (goto-char end-marker)
  175.     (or (eobp)
  176.     (not (= 0 (nth 3 element)))
  177.     ;; for -R style, want a separating newline _between_ subdirs.
  178.     (forward-char -1))
  179.     (if (= 0 (nth 3 element))
  180.     (insert "\n\n"))
  181.     (prog1
  182.     (dired-remember-marks begin-marker (point))
  183.       (delete-region begin-marker (point)))))
  184.  
  185.  
  186. (defun dired-insert-subdir-doupdate (dirname elt beg-end)
  187.   (let ((beg (nth 0 beg-end))
  188.     (end (nth 1 beg-end))
  189.     (indent (or (nth 2 beg-end) 0)))
  190.     (if (and elt
  191.          (not (eq indent (nth 2 elt))))
  192.     (setq elt nil
  193.           dired-subdir-alist (delq elt dired-subdir-alist)))
  194.     (if elt
  195.     (let ((old-start (nth 1 elt))
  196.           (old-end   (nth 2 elt)))
  197.       (set-marker old-start beg)
  198.       (set-marker old-end end)
  199.       (setcar (nthcdr 3 elt) indent))
  200.       (dired-alist-add dirname
  201.                (set-marker (make-marker) beg)
  202.                (set-marker (make-marker) end)
  203.                indent))))
  204.  
  205. (defun dired-insert-subdir-inline (dirname &optional switches no-error-if-not-dir-p)
  206.   "Insert this subdirectory into the same dired buffer.
  207. If it is already present, overwrites previous entry,
  208.   else inserts it, indented, within its parent's listing.
  209. With a prefix arg, you may edit the ls switches used for this listing.
  210.   This command ignores the `R' switch."
  211.   ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like
  212.   ;; Prospero where dired-ls does the right thing, but
  213.   ;; file-directory-p has not been redefined.
  214.   (interactive
  215.    (list (dired-get-filename)
  216.      (if current-prefix-arg
  217.          (read-string "Switches for listing: " dired-actual-switches))))
  218.   (setq dirname (file-name-as-directory (expand-file-name dirname)))
  219.   (if (let ((case-fold-search nil))
  220.     (string-match "R" (or switches "")))
  221.       (setq switches (concat (substring switches 0 (match-beginning 0))
  222.                  (substring switches (match-end 0)))))
  223.   (dired-make-relative dirname default-directory) ; error on failure
  224.   (or no-error-if-not-dir-p
  225.       (file-directory-p dirname)
  226.       (error  "Attempt to insert a non-directory: %s" dirname))
  227.   (let ((elt (assoc dirname dired-subdir-alist))
  228.     (parentdir (file-name-directory (directory-file-name dirname)))
  229.     beg end old-start old-end new-start new-end
  230.     mark-alist
  231.     tail-adjascents
  232.     buffer-read-only case-fold-search)
  233.     (if elt
  234.     ;; subdir is already present - must first erase it from buffer.
  235.     ;; if it's already in -R format, pretend it wasn't there, but
  236.     ;; remember its file marks.
  237.     (progn
  238.       (setq mark-alist
  239.         (append (dired-insert-subdir-del elt) mark-alist))
  240.       (setq dired-subdir-alist
  241.         (delq elt dired-subdir-alist))))
  242.     ;;(dired-insert-subdir-newpos) ;##
  243.     (dired-goto-file dirname)
  244.     (forward-line 1)
  245.     (dired-insert-subdir-doupdate
  246.      dirname elt (dired-insert-subdir-inline-doinsert dirname switches parentdir))
  247.     (dired-initial-position dirname)
  248.     (save-excursion (dired-mark-remembered mark-alist)))
  249.   (dired-nuke-extra-newlines)
  250.   )
  251.  
  252.  
  253. (defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p)
  254.   "Insert this subdirectory into the same dired buffer.
  255. If it is already present, overwrites previous entry,
  256.   else appends at end of buffer.
  257. With a prefix arg, you may edit the ls switches used for this listing.
  258.   You can add `R' to the switches to expand the whole tree starting at
  259.   this subdirectory.
  260. This function takes some pains to conform to ls -lR output."
  261.   ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like
  262.   ;; Prospero where dired-ls does the right thing, but
  263.   ;; file-directory-p has not been redefined.
  264.   (interactive
  265.    (list (dired-get-filename)
  266.      (if current-prefix-arg
  267.          (read-string "Switches for listing: " dired-actual-switches))))
  268.   (setq dirname (file-name-as-directory (expand-file-name dirname)))
  269.   (dired-make-relative dirname default-directory) ; error on failure
  270.   (or no-error-if-not-dir-p
  271.       (file-directory-p dirname)
  272.       (error  "Attempt to insert a non-directory: %s" dirname))
  273.   (let ((elt (assoc dirname dired-subdir-alist))
  274.     (switches-have-R (and switches (string-match "R" switches)))
  275.     mark-alist
  276.     buffer-read-only case-fold-search)
  277.     (if switches-have-R            ; avoid double subdirs
  278.     (setq mark-alist (dired-kill-tree dirname t)))
  279.     (let ((was-nested (and (nth 3 elt) (not (eq 0 (nth 3 elt))))))
  280.       (if elt                ; subdir is already present
  281.       (setq mark-alist        ; remove it, remembering marks
  282.         (append (dired-insert-subdir-del elt) mark-alist)))
  283.       (if (or was-nested (null elt))
  284.       (dired-insert-subdir-newpos dirname))
  285.       (if was-nested (setcar (nthcdr 3 elt) 0)))
  286.     (dired-insert-subdir-doupdate
  287.      dirname elt (dired-insert-subdir-doinsert dirname switches))
  288.     (if switches-have-R (dired-build-subdir-alist))
  289.     (dired-initial-position dirname)
  290.     (save-excursion (dired-mark-remembered mark-alist)))
  291.   (dired-nuke-extra-newlines))
  292.  
  293. (defun dired-nuke-extra-newlines ()
  294.   (let ((buffer-read-only nil))
  295.     (save-excursion
  296.       (goto-char (point-min))
  297.       (while (re-search-forward "\n\n\n+" nil t)
  298.     (goto-char (+ 2 (match-beginning 0)))
  299.     (delete-region (point) (match-end 0))))))
  300.  
  301.  
  302. (defun dired-insert-subdir-newpos (new-dir)
  303.   ;; Find pos for new subdir, according to tree order.
  304.   ;;(goto-char (point-max))
  305.   (let ((alist dired-subdir-alist) elt dir pos new-pos)
  306.     (while alist
  307.       (setq elt (car alist)
  308.         alist (cdr alist)
  309.         dir (car elt)
  310.         pos (dired-get-subdir-min elt))
  311.       (if (and (= 0 (nth 3 elt)) ; nested ones don't count.
  312.            (dired-tree-lessp dir new-dir))
  313.       ;; Insert NEW-DIR after DIR
  314.       (setq new-pos (dired-get-subdir-max elt)
  315.         alist nil)))
  316.     (goto-char new-pos))
  317.   ;; want a separating newline between subdirs
  318.   (insert "\n\n")
  319.   (point))
  320.  
  321.  
  322. (defvar dired-no-inline-headerlines t
  323.   "*set this to t to suppress the directory header and `total' line.")
  324.  
  325.  
  326. (defun dired-insert-subdir-inline-doinsert (dirname switches parentdir)
  327.   ;; Insert ls output after point and put point on the correct
  328.   ;; position for the subdir alist.
  329.   ;; returns the dired-subdir-alist entry.
  330.   (let ((begin (point)) end
  331.     indent
  332.     tail-adjascents)
  333.     (message "Reading directory %s..." dirname)
  334.     (dired-ls dirname
  335.           (or switches
  336.           (dired-replace-in-string "R" "" dired-actual-switches))
  337.           nil t)
  338.     (message "Reading directory %s...done" dirname)
  339.     (setq end (point))
  340.     (setq indent (1+ (nth 3 (assoc parentdir dired-subdir-alist))))
  341.  
  342.     (save-excursion
  343.       (goto-char begin)
  344.       (or dired-no-inline-headerlines
  345.       (progn
  346.         (dired-insert-headerline dirname)
  347.         (save-excursion (delete-horizontal-space)))
  348.       (goto-char begin)
  349.       (delete-horizontal-space))
  350.       (if (and dired-no-inline-headerlines
  351.            (looking-at "^ *total [0-9]"))
  352.       (progn
  353.         (delete-region (point) (progn (forward-line 1) (point)))
  354.         (setq begin (point)))))
  355.     ;;
  356.     ;; If there are other directories whose end-point is right here,
  357.     ;; then they are the directories such that X is the last directory
  358.     ;; in the listing of Y.  We need to grab them and update their
  359.     ;; last-point to be the same as ours will be (goofy margin-case).
  360.     ;;
  361.     (let ((rest dired-subdir-alist))
  362.       (while rest
  363.     (if (= (point) (nth 2 (car rest)))
  364.         (setq tail-adjascents (cons (car rest) tail-adjascents)))
  365.     (setq rest (cdr rest))))
  366.     (let ((indent-tabs-mode nil))
  367.       (indent-rigidly begin (point) (* 2 (1+ indent))))
  368.     (setq end (point-marker))
  369.     (goto-char begin)
  370.     (while tail-adjascents
  371.       (set-marker (nth 2 (car tail-adjascents)) end)
  372.       (setq tail-adjascents (cdr tail-adjascents)))
  373.     (if dired-after-readin-hook
  374.     (save-restriction
  375.       (narrow-to-region begin end)
  376.       (run-hooks 'dired-after-readin-hook)))
  377.     ;;  call dired-insert-headerline afterwards, as under VMS dired-ls
  378.     ;;  does insert the headerline itself and the insert function just
  379.     ;;  moves point.
  380.     (setq end (prog1 (marker-position end) (set-marker end nil)))
  381.     (goto-char begin)
  382.     (list begin end indent)))
  383.  
  384.  
  385. (defun dired-insert-subdir-doinsert (dirname switches)
  386.   ;; Insert ls output after point and put point on the correct
  387.   ;; position for the subdir alist.
  388.   ;; Return the boundary of the inserted text (as list of BEG and END).
  389.   (let ((begin (point)) end)
  390.     (message "Reading directory %s..." dirname)
  391.     (dired-ls dirname
  392.           (or switches
  393.           (dired-replace-in-string "R" "" dired-actual-switches))
  394.           nil t)
  395.     (message "Reading directory %s...done" dirname)
  396.     (insert "\n\n")
  397.     (setq end (point-marker))
  398.     (indent-rigidly begin (point) 2)
  399.     (if dired-after-readin-hook
  400.     (save-restriction
  401.       (narrow-to-region begin (point))
  402.       (run-hooks 'dired-after-readin-hook)))
  403.     ;;  call dired-insert-headerline afterwards, as under VMS dired-ls
  404.     ;;  does insert the headerline itself and the insert function just
  405.     ;;  moves point.
  406.     (goto-char begin)
  407.     (dired-insert-headerline dirname)
  408.     ;; point is now like in dired-build-subdir-alist
  409.     (setq end (prog1 (marker-position end) (set-marker end nil)))
  410.     (list begin end)))
  411.  
  412.  
  413. (defun dired-insert-old-subdirs (old-subdir-alist)
  414.   ;; Try to insert all subdirs that were displayed before
  415.   (or (string-match "R" dired-actual-switches)
  416.       (let (elt dir)
  417.     (setq old-subdir-alist (sort old-subdir-alist
  418.                      (function (lambda (x y)
  419.                        (< (nth 3 x) (nth 3 y))))))
  420.     (while old-subdir-alist
  421.       (setq elt (car old-subdir-alist)
  422.         old-subdir-alist (cdr old-subdir-alist)
  423.         dir (car elt))
  424.       (condition-case ()
  425.           (if (= 0 (nth 3 elt))
  426.           (dired-insert-subdir dir)
  427.           (dired-insert-subdir-inline dir))
  428.         (error nil))))))
  429.  
  430. (defun dired-add-entry-do-indentation (marker-char)
  431.   ;; two spaces or a marker plus a space, plus nesting indentation.
  432.   ;; Uses fluid vars `directory', `marker-char' from dired-add-entry
  433.   (insert (if marker-char
  434.           (if (integerp marker-char) marker-char dired-marker-char)
  435.         ?\040)
  436.       ?\040)
  437.   (let ((indent (nth 3 (assoc directory dired-subdir-alist))))
  438.     (insert (make-string (* 2 indent) ?\040))))
  439.